home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / defmacex < prev    next >
Text File  |  1994-02-17  |  2KB  |  85 lines
  1. ;;;defmacro:expand* for any Scheme dialect.
  2. ;;;Copyright 1993-1994 Dorai Sitaram and Aubrey Jaffer.
  3.  
  4. ;;;expand thoroughly, not just topmost expression.  While expanding
  5. ;;;subexpressions, the primitive forms quote, lambda, set!, let/*/rec,
  6. ;;;cond, case, do, quasiquote: need to be destructured properly.  (if,
  7. ;;;and, or, begin: don't need special treatment.)
  8.  
  9. (define (defmacro:iqq e depth)
  10.   (letrec
  11.       ((map1 (lambda (f x)
  12.            (if (pair? x) (cons (f (car x)) (map1 f (cdr x)))
  13.            x)))
  14.        (iqq (lambda (e depth)
  15.           (if (pair? e)
  16.           (case (car e)
  17.             ((quasiquote) (list (car e) (iqq (cadr e) (+ 1 depth))))
  18.             ((unquote unquote-splicing)
  19.              (list (car e) (if (= 1 depth)
  20.                        (defmacro:expand* (cadr e))
  21.                        (iqq (cadr e) (+ -1 depth)))))
  22.             (else (map1 (lambda (e) (iqq e depth)) e)))
  23.           e))))
  24.     (iqq e depth)))
  25.  
  26. (define (defmacro:expand* e)
  27.   (if (pair? e)
  28.       (let* ((c (macroexpand-1 e)))
  29.     (if (not (eq? e c))
  30.         (defmacro:expand* c)
  31.         (case (car e)
  32.           ((quote) e)
  33.           ((quasiquote) (defmacro:iqq e 0))
  34.           ((lambda)
  35.            (cons 'lambda (cons (cadr e)
  36.                    (map defmacro:expand* (cddr e)))))
  37.           ((set!)
  38.            `(set! ,(cadr e)
  39.               ,(defmacro:expand* (caddr e))))
  40.           ((let)
  41.            (let ((b (cadr e)))
  42.          (if (symbol? b)    ;named let
  43.              `(let ,b
  44.             ,(map (lambda (vv)
  45.                 `(,(car vv)
  46.                   ,(defmacro:expand* (cadr vv))))
  47.                   (caddr e))
  48.             ,@(map defmacro:expand*
  49.                    (cdddr e)))
  50.              `(let
  51.               ,(map (lambda (vv)
  52.                   `(,(car vv)
  53.                     ,(defmacro:expand* (cadr vv))))
  54.                 b)
  55.             ,@(map defmacro:expand*
  56.                    (cddr e))))))
  57.           ((let* letrec)
  58.            `(,(car e) ,(map (lambda (vv)
  59.                   `(,(car vv)
  60.                     ,(defmacro:expand* (cadr vv))))
  61.                 (cadr e))
  62.               ,@(map defmacro:expand* (cddr e))))
  63.           ((cond)
  64.            `(cond
  65.          ,@(map (lambda (c)
  66.               (map defmacro:expand* c))
  67.             (cdr e))))
  68.           ((case)
  69.            `(case ,(defmacro:expand* (cadr e))
  70.           ,@(map (lambda (c)
  71.                `(,(car c)
  72.                  ,@(map defmacro:expand* (cdr c))))
  73.              (cddr e))))
  74.           ((do)
  75.            `(do ,(map
  76.               (lambda (initsteps)
  77.             `(,(car initsteps)
  78.               ,@(map defmacro:expand*
  79.                  (cdr initsteps))))
  80.               (cadr e))
  81.             ,(map defmacro:expand* (caddr e))
  82.           ,@(map defmacro:expand* (cdddr e))))
  83.           (else (map defmacro:expand* e)))))
  84.       e))
  85.